home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Mops 2.5 / Mops ƒ / Base < prev    next >
Encoding:
Text File  |  1994-10-02  |  12.3 KB  |  489 lines  |  [TEXT/MSET]
  1. \ Sept 92 mrh    New words etc. moving closer to ANSI standard
  2. \ Jul  93 mrh    Select{  removed - replaced by Select[ in caseMod
  3.  
  4.  
  5. false    value    ECHO?        \ echo load to screen?
  6.  
  7.  
  8. \ (* ... *) defines a multi-line comment, which can be very useful.  Many
  9. \ Pascal compilers use these symbols - I thought it better not to use
  10. \ the C-style /* ... */  since */ already has a meaning.
  11. \ A useful improvement to the typical Pascal implementation is to keep a
  12. \ level count so that this kind of comment can be nested.
  13.  
  14. : (*
  15.     1                            \ initial level count
  16.     BEGIN
  17.         Mword  count  2dup
  18.         " (*"  s=
  19.         IF    2drop  1 +            \ increment level count
  20.         ELSE
  21.             " *)"  s=
  22.             IF  1 -                \ decrement level count
  23.                 ?dup  0EXIT        \ and if zero, we're done
  24.             THEN
  25.         THEN
  26.     AGAIN  ;        immediate
  27.  
  28.  
  29. \ We redefine a few useful words to take advantage of our optimization.
  30.  
  31. : 1+    state IF 1 postpone literal  postpone +  ELSE  1 +  THEN  ;    immediate
  32. : 2+    state IF 2 postpone literal  postpone +  ELSE  2 +  THEN  ;    immediate
  33. : 3+    state IF 3 postpone literal  postpone +  ELSE  3 +  THEN  ; immediate
  34. : 4+    state IF 4 postpone literal  postpone +  ELSE  4 +  THEN  ; immediate
  35.  
  36. : 1-    state IF 1 postpone literal  postpone -  ELSE  1 -  THEN  ;    immediate
  37. : 2-    state IF 2 postpone literal  postpone -  ELSE  2 -  THEN  ;    immediate
  38. : 3-    state IF 3 postpone literal  postpone -  ELSE  3 -  THEN  ;    immediate
  39. : 4-    state IF 4 postpone literal  postpone -  ELSE  4 -  THEN  ;    immediate
  40.  
  41. : 2*    state IF 1 postpone literal  postpone << ELSE  1 << THEN  ;    immediate
  42. : 2/    state IF 1 postpone literal  postpone a>> ELSE 1 a>> THEN ;    immediate
  43. : 4*    state IF 2 postpone literal  postpone << ELSE  2 << THEN  ;    immediate
  44. : 4/    state IF 2 postpone literal  postpone a>> ELSE 2 a>> THEN ;    immediate
  45.  
  46. \ ANSI words
  47.  
  48. : CELL+    state IF  postpone 4+  else  4 +  THEN  ;    immediate
  49. : CELL-    state IF  postpone 4-  else  4 -  THEN  ;    immediate
  50. : CELLS    state IF  2 postpone literal  postpone <<  ELSE    2 <<  THEN  ;  immediate
  51. : CHAR+    state IF  postpone 1+  else  1 +  THEN  ;    immediate
  52. : CHARS    ;                        immediate
  53.  
  54. 4    constant    1CELL            \ Not ANSI, but useful
  55.  
  56.  
  57. : RECURSE        curr-def  compile,  ;            immediate
  58.  
  59. : SAVE-INPUT
  60.     src-start  src-len  >in @  source-id  4  ;
  61.  
  62. : RESTORE-INPUT
  63.     dup 4 <>  IF  true  EXIT  THEN
  64.     drop
  65.     -> source-id  >in !  -> src-len  -> src-start  false  ;
  66.  
  67.  
  68. \        =========================
  69.  
  70.  
  71. \ .H and U.H print a number in hex, signed and unsigned respectively.
  72.  
  73. : .H    base >r  hex   .  r> -> base  ;
  74. : U.H    base >r  hex  u.  r> -> base  ;
  75.  
  76.  
  77.     0    constant    Z
  78.  
  79. : NULLOSSTR        ['] z  ;
  80.  
  81.  
  82. : @WORD        \ ( -- addr )  Retrieves next blank-delimited word from input stream.
  83.     BL word  ;
  84.  
  85. : LIT        \ ( n -- )  A state-smart version of LITERAL.  Corresponds
  86.             \ to LITERAL in Fig-Forth or original Neon, whereas our
  87.             \ present LITERAL is Forth-83/ANSI.
  88.     state  IF  postpone literal  THEN  ;        immediate
  89.  
  90. : 0,  0 ,  ;        \ Compiles an empty cell
  91.  
  92. : @VAL    intrp1  ;    \ Compiles a number from input stream
  93.  
  94.  
  95. : 'TYPE        \ ( -- 4bytes )   OS type literal
  96.     pad 4 bl fill  @word count 4 min
  97.     pad swap cmove  pad @  postpone lit  ;    immediate
  98.  
  99. create BUF255  256 allot        \ buffer for string operations
  100.  
  101. : >STR255        \ ( addr len addr -- addr )
  102.                 \ Converts a string to a Str255 at addr
  103.     dup >r  place  r>  ;
  104.  
  105. : STR255    \ ( -- ^buf255 )
  106.     buf255 >str255  ;
  107.  
  108.  
  109. : $        \ State-smart HEX literal word
  110.     base >r
  111.     hex  Mword  number  postpone lit
  112.     r> -> base  ;            immediate
  113.  
  114.  
  115. : LITW        \ ( n -- )
  116.     $ 3D3C w,  w,  ;
  117.  
  118.  
  119. : W        intrp1  litw  ;        immediate
  120.  
  121.  
  122. \ Trap compilation.  We've changed the syntax from Neon's  $ xxxx TRAP
  123. \ to  TRAP$ xxxx.  This is because we are now compiling in-line trap
  124. \ calls, to avoid problems with self-modifying code, and also because Apple
  125. \ are now defining traps that way.
  126.  
  127. : SAVA5        postpone doSavA5  ;
  128.  
  129. : RSTA5
  130.     $ CD4F w,            \    exg    a6,a7
  131.     $ 2A5F w,  ;        \    move.l    (a7)+,a5
  132.  
  133. : (TRAP$)    \ ( trap# -- )  Compiles a call to the given trap.
  134.     SavA5  w,  RstA5  ;
  135.  
  136. : TRAP$        \ ( --<trap#> )
  137.     base >r
  138.     hex  intrp1  (trap$)
  139.     r> -> base  ;        immediate
  140.  
  141.  
  142. : (FDOS$)        \ ( trap# -- )
  143.     $ 205E w,                \    move.l    (a6)+,a0    ; FCB pointer
  144.     SavA5  w,  RstA5
  145.     $ 48C0 w,                \    ext.l    d0    ; Result
  146.     $ 2D00 w,  ;            \    move.l    d0,-(a6)
  147.  
  148.  
  149. : FDOS$        \ ( --<trap#> )
  150.     base >r
  151.     hex  intrp1  (fdos$)
  152.     r> -> base  ;        immediate
  153.  
  154.  
  155. \            ==================
  156.  
  157. 0  value    ResRefNum
  158.  
  159. : OpenResFile        \ ( addr len -- )  Opens named resource file
  160.     >r >r word0 r> r> str255
  161.     trap$ a997  i->l                \ call OpenResFile
  162.     dup -> ResRefNum
  163.     -1 = abort" resource file open failed"  ;
  164.  
  165. : CloseResFile        \ ( -- )
  166.     ResRefnum  makeint  trap$ a99a  ;
  167.  
  168.  
  169. : OPENMR            \ Opens the Mops system resource file if necessary.
  170.     MRopen?  ?EXIT                    \ Do nothing if already open
  171.     instld?  ?EXIT                    \ or if this is an installed application
  172.     " mops.rsrc" OpenResFile
  173.     true -> MRopen?  ;
  174.  
  175.  
  176. : CHAR        @word 1+ c@  ;                \ ANSI - replaces ASCII
  177. : [CHAR]    @word 1+ c@  postpone literal  ;    immediate
  178.  
  179. : &            \ ( -- c )  A shorter state-smart version.
  180.     @word 1+ c@  postpone lit  ;        immediate
  181.  
  182.  
  183. : GETSTRING        \ ( resID -- addr len )  Get the string with resource ID
  184.     openMR
  185.     0 swap makeint  trap$ a9ba        \ call getString
  186.     dup if  @ count  else  0  then  ;
  187.  
  188.  
  189. : (TSTR)            \ ( id# -- )  Prints string with given resID.
  190.     getString type  ;
  191.  
  192. : X    ['] (tstr) -> tstr  ;        \ We can't do -> outside a defn till Args loaded
  193. x  forget x
  194.  
  195.  
  196. \ Our normal error action is to call DIE with an error number.  DIE calls
  197. \ SvErr to save the error info, then THROWs the error number.  If no error
  198. \ handler has been installed, or only handlers which don't want that number
  199. \ and re-THROW it, the default action for THROW occurs.  This calls DFLT-DIE.
  200.  
  201. : (DDIE)            \ ( n -- )
  202.     setFwind
  203.     +echo   0 -> (err#)        \ Clear error indicator from AppleEvents
  204.     dflt-err  ;                \ Display error info and abort
  205.  
  206. : x    ['] (ddie) -> dflt-die  ;
  207. x  forget x
  208.  
  209.  
  210. : ?ERROR        \ ( b -- )  Aborts and prints resource string if true.
  211.                 \ Usage:  ?error 999
  212.     postpone if
  213.     intrp1  ( get err# )  postpone literal   postpone die
  214.     postpone then  ;        immediate
  215.  
  216.  
  217. : TYPE#        \ Prints string for id# in stream
  218.     intrp1  postpone lit   postpone (tStr)  ;    immediate
  219.  
  220.  
  221. : (.RSTR)    \ ( -- )  print "Msg# ..." then string with given resID
  222.     ." Msg# " dup . ." : "  (tStr)  ;
  223.  
  224.  
  225. : MSG#        \  usage: " Msg# <number>"
  226.     intrp1  postpone lit  postpone (.rStr)  ;    immediate
  227.  
  228.  
  229. \        ============ Resources ===========
  230.  
  231.  
  232. : GETRES    \ ( type resID -- handle )
  233.     0 down makeint  trap$ a9a0  ;        \ call GetResource
  234.  
  235.  
  236. \ ( -- #cells)
  237.  
  238. : RDEPTH        rp0  rp@ - 4/ 2-  ;
  239.  
  240. : ?RDEPTH        rp@  sp0 20 + < ?error 116  ;    \ err if rtn stk about to
  241.                                                 \ collide with data stk
  242.  
  243.  
  244. \        ========== Type checking ===========
  245.  
  246. \ Sometimes we want to check that a non-object parameter to a word is of a 
  247. \ certain type.  We give it a unique type code and use TYPCHK.
  248.  
  249. : TYPCHK    <>  ?error 179  ;
  250.  
  251.  
  252. \        ========== Forward definitions ===========
  253.  
  254.  
  255. : X    setfWind +echo
  256.     cr ." From " r@ .id  2 spaces  r@ .h  109 die  ;
  257.  
  258.  
  259. : FORWARD
  260.     colHdr
  261.     $ 487AFFFE  ,                \    pea   (start of this instrn)
  262.     ['] x  here  6 allot
  263.     (patch)  ;
  264.  
  265. : :F    301
  266.     here  '  (patch)  :noname  ;
  267.  
  268. : ;F    (;)  301 ?defn  ;        immediate
  269.  
  270.  
  271. forward    BLD        \ Used in CLASS.  Needs to be down here so we never
  272.                 \ refer to it with a short branch.  Kludge?
  273.  
  274. \ Commonly needed error words.  These are forward defined - the main
  275. \ application should provide a sensible definition, with a nice friendly
  276. \ alert box, to tell the user in a nice friendly way that things are up
  277. \ the creek.
  278.  
  279. forward    NOMEM        \ Call when (not if!) we run out of memory.
  280.  
  281. forward    I/O_ERR        \ ( err# -- )  Call when there's an I/O error.
  282.  
  283. : OK?        \ ( rc -- )  A useful word to use after an I/O op.
  284.     ?dup  0EXIT  I/O_err  ;
  285.  
  286.  
  287. \        ========= :PROC and ;PROC ============
  288.  
  289. : :PROC
  290.     colHdr  here  6 allot
  291.     ['] procEntry  swap  6  aligned_move
  292.     :noname  303  ;        immediate
  293.  
  294. : ;PROC        immediate
  295.     postpone procExit  (;)
  296.     303 ?defn  ;
  297.  
  298.  
  299. \     ======== Various utility words needed later =========
  300.  
  301. \ BECOME allows restarting at a given word, with all stacks
  302. \ empty.  This is necessary in menu handlers and other areas
  303. \ that could create indefinite nesting situations.
  304.  
  305. ' quit    vect    BECOMECFA
  306.  
  307. : BE    sp0 sp!  rp0 rp!  becomeCfa  quit  ;
  308.  
  309. : (BE)    -> becomeCfa be  ;
  310.  
  311.  
  312. : BECOME        \ Usage: Become newWord - compiles code to Be at runtime
  313.     state
  314.     IF        postpone [']  postpone (be)
  315.     ELSE    '  -> becomeCfa  be
  316.     THEN  ;            immediate
  317.  
  318.  
  319. : DATETIME
  320.     $ 20C  @  ;
  321.  
  322.  
  323. \        ============ Tables, lists etc. ===============
  324.  
  325. (*    With Mops 2.5 we're trying to be consistent with the way we delimit
  326.     various kinds of lists with { ... }.  No, we're not trying to copy C,
  327.     but let's at least follow the "principle of minimum astonishment"!
  328.     Thus, with words like xts{, we'll allow a variant "xts {" where you
  329.     can put a space before the "{".  This is very easy to implement, so
  330.     why not?
  331. *)
  332.  
  333. forward  {        immediate
  334.  
  335. : GOBBLE{        \ gobbles a "{" which must follow as a separate word.
  336.     '  ['] {  <>  ?error 113  ;        \ "{" expected
  337.  
  338. : )        123 die  ;    immediate        \ ") read when no list is current"
  339. : (})    123 die  ;    immediate        \ "unmatched }"
  340.  
  341. ' (})    vect    }                    \ } will mean different things in different
  342.                                     \  contexts.
  343.  
  344. : }OR)?        \ ( cfa -- cfa b )
  345.     dup  ['] }  =  over  ['] ) =  or  ;
  346.  
  347. (*
  348. : TABLE
  349.     <BUILDS        0 w,  here  112
  350.     DOES>        length  ;
  351.  
  352. : END_TABLE
  353.     112 ?pairs
  354.     here over -            \ table length (excluding length field)
  355.     swap 2- w!  ;        \ store in length field
  356. *)
  357.     0    value        CNT
  358.  
  359.  
  360. : (LITS)        \ stack compiled list of values starting at IP
  361.     w@(ip)  ( count )  dup  -> cnt
  362.     4* r> tuck +  dup >r  swap
  363.     do  i @abs  4 +loop
  364.     cnt  ;
  365.  
  366.  
  367. : XTS{            \ State-smart word to compile or stack a list
  368.                 \ of xts.  Pulls words from stream, until "}".
  369.     state IF   postpone (lits)  here  0 w,  THEN
  370.     0
  371.     BEGIN   '   }or)?
  372.     NWHILE   state IF  reloc,  else  swap  THEN  1+
  373.     REPEAT
  374.     drop   state IF  swap w!  THEN  ;        immediate
  375.  
  376. : CFAS{    postpone xts{  ;    immediate        \ Synonyms for compatibility
  377. : CFAS(    postpone xts{  ;    immediate
  378.  
  379. : XTS    gobble{  postpone xts{  ;        immediate
  380.  
  381.  
  382. : RESERVE        \ ( len -- )  Allot and clear.
  383.     here over erase allot  ;
  384.  
  385.  
  386. \ SCON defines a string constant.  Usage:
  387. \
  388. \    scon    <name>    "a string"
  389. \
  390. \ Runtime: ( -- addr len )
  391. \
  392. \ Change from Neon: the first nonblank char after the name of the SCON
  393. \ becomes the delimiter.  So " can be used as usual, but anything else can
  394. \ be used instead, e.g.:
  395. \
  396. \    scon    <name>    /this string contains " as non-delimiter/
  397.  
  398. : SCON
  399.     <BUILDS        bl skip-src+
  400.                 src-start >in @ + c@  ,dlm-str
  401.     DOES>        count  ;
  402.  
  403.  
  404. \ CASE should be used for non-contiguous or dynamically computed values.
  405. \ This is a modified Eaker/Duncan model.
  406. \ Our optimization strategy gives quite good code.
  407.  
  408. : CASE        ?comp  302  ;        immediate
  409.  
  410. : OF
  411.     postpone over  postpone =  postpone if
  412.     postpone drop  ;            immediate
  413.  
  414. : RANGEOF
  415.     postpone within?  postpone if
  416.     postpone drop  ;            immediate
  417.  
  418. : ENDOF
  419.     postpone else  ;            immediate
  420.  
  421. : ENDCASE        immediate
  422.     postpone drop
  423.     BEGIN  dup 302 =  NWHILE  >resolve  REPEAT  drop  ;
  424.  
  425. (*
  426. TYPE{ and ENUM{ (synonyms) define a Pascal/C-like enumerated type.
  427. At this stage we don't give a name to the "type" as such, as we can't
  428. do anything really sensible with it.  However later we can optionally
  429. load the ENUM-TYPE class which is rather more Pascal-like.  But even
  430. without that, the enumeration is very useful by itself.
  431. *)
  432.  
  433.     0    value    TYPECNT
  434.  
  435. ' null    vect    DO_ET        \ Hook for handling the ENUM-TYPE
  436.                             \ class when it's loaded
  437.                             
  438. : ENDLIST?        \ ( chr -- b )
  439.     latest n>count 1 =  down  c@ =  and
  440.     dup  IF  latest n>link  (forget)  THEN  ;
  441.  
  442.  
  443. : TYPE{
  444.     0 -> typeCnt                \ 1st value
  445.     BEGIN    typeCnt  constant  1 ++> typeCnt
  446.             & }  endlist?
  447.     UNTIL
  448.     do_ET  ;
  449.  
  450. : ENUM{        type{  ;            \ C fans might like this name better
  451. : ENUM        gobble{  type{  ;
  452.  
  453.                 \ note we can't allow "type { ..." since "type" has another
  454.                 \ meaning already.  But "enum { ..."  is OK.
  455.  
  456. type{  InMainDic  InOtherMod  InThisMod  }        \ Relocatable addr types
  457.  
  458.  
  459. \        ========== Error diagnostics ===========
  460.  
  461. \ We use special values for nil handles and nil pointers.  These are
  462. \ odd addresses in ROM, so that if we do a word or long access we will
  463. \ trap, and if we write a byte it at least won't go anywhere.
  464.  
  465.  
  466. : .RTN        \ ( addr -- )
  467.     cr ." From  $"  .h  4 spaces  ;
  468.  
  469. : RANGE_ERR    \ ( index range rtn-addr -- )
  470.     dup 1+ 0=  ?error 128            \ Spurious range error
  471.     .rtn
  472.     dup -1 <
  473.     IF        nip  ?error 130            \ Not an indexed class
  474.     ELSE    ." Range: " .  ."   Index: " .
  475.             true  ?error 129
  476.     THEN  ;
  477.  
  478.  
  479. \ If we do software mult and div (on a 68000 which only allows a 16-bit divisor or
  480. \ multiplicand) we also check for overflow and call ArithErr (vector) if ovfl occurs.  
  481. \ The appropriate err# is on the stack already, so here we just set ArithErr to Die.
  482. \ This can be redirected as needed.
  483.  
  484. : X    ['] range_err -> rngErr   ['] die  -> arithErr  ;
  485.  
  486. x   forget x
  487.  
  488. <" Args
  489.